home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / scanf.scm < prev    next >
Text File  |  1999-04-19  |  11KB  |  351 lines
  1. ;;;;"scanf.scm" implemenation of formated input
  2. ;Copyright (C) 1996, 1997 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;; Originally jjb@isye.gatech.edu (John Bartholdi) wrote some public
  21. ;;; domain code for a subset of scanf, but it was too difficult to
  22. ;;; extend to POSIX pattern compliance.  Jan 96, I rewrote the scanf
  23. ;;; functions starting from the POSIX man pages.
  24.  
  25. (require 'string-port)
  26.  
  27. (define (stdio:scan-and-set format-string input-port . args)
  28.   (define setters args)
  29.   (if (equal? '(#f) args) (set! args #f))
  30.   (cond
  31.    ((not (equal? "" format-string))
  32.     (call-with-input-string
  33.      format-string
  34.      (lambda (format-port)
  35.  
  36.        (define items '())
  37.        (define chars-scanned 0)
  38.        (define assigned-count 0)
  39.  
  40.        (define (char-non-numeric? c) (not (char-numeric? c)))
  41.  
  42.        (define (flush-whitespace port)
  43.      (do ((c (peek-char port) (peek-char port))
  44.           (i 0 (+ 1 i)))
  45.          ((or (eof-object? c) (not (char-whitespace? c))) i)
  46.        (read-char port)))
  47.  
  48.        (define (flush-whitespace-input)
  49.      (set! chars-scanned (+ (flush-whitespace input-port) chars-scanned)))
  50.  
  51.        (define (read-input-char)
  52.      (set! chars-scanned (+ 1 chars-scanned))
  53.      (read-char input-port))
  54.  
  55.        (define (add-item report-field? next-item)
  56.      (cond (args
  57.         (cond ((and report-field? (null? setters))
  58.                (slib:error 'scanf "not enough variables for format"
  59.                    format-string))
  60.               ((not next-item) (return))
  61.               ((not report-field?) (loop1))
  62.               (else
  63.                (let ((suc ((car setters) next-item)))
  64.              (cond ((not (boolean? suc))
  65.                 (slib:warn 'scanf "setter returned non-boolean"
  66.                        suc)))
  67.              (set! setters (cdr setters))
  68.              (cond ((not suc) (return))
  69.                    ((eqv? -1 report-field?) (loop1))
  70.                    (else
  71.                 (set! assigned-count (+ 1 assigned-count))
  72.                 (loop1)))))))
  73.            ((not next-item) (return))
  74.            (report-field? (set! items (cons next-item items))
  75.                   (loop1))
  76.            (else (loop1))))
  77.  
  78.        (define (return)
  79.      (cond ((and (zero? chars-scanned)
  80.              (eof-object? (peek-char input-port)))
  81.         (peek-char input-port))
  82.            (args assigned-count)
  83.            (else (reverse items))))
  84.  
  85.        (define (read-string width separator?)
  86.      (cond (width
  87.         (let ((str (make-string width)))
  88.           (do ((i 0 (+ 1 i)))
  89.               ((>= i width)
  90.                str)
  91.             (let ((c (peek-char input-port)))
  92.               (cond ((eof-object? c)
  93.                  (set! str (substring str 0 i))
  94.                  (set! i width))
  95.                 ((separator? c)
  96.                  (set! str (if (zero? i) "" (substring str 0 i)))
  97.                  (set! i width))
  98.                 (else
  99.                  (string-set! str i (read-input-char))))))))
  100.            (else
  101.         (do ((c (peek-char input-port) (peek-char input-port))
  102.              (l '() (cons c l)))
  103.             ((or (eof-object? c) (separator? c))
  104.              (list->string (reverse l)))
  105.           (read-input-char)))))
  106.  
  107.        (define (read-word width separator?)
  108.      (let ((l (read-string width separator?)))
  109.        (if (zero? (string-length l)) #f l)))
  110.  
  111.        (define (loop1)
  112.      (define fc (read-char format-port))
  113.      (cond
  114.       ((eof-object? fc)
  115.        (return))
  116.       ((char-whitespace? fc)
  117.        (flush-whitespace format-port)
  118.        (flush-whitespace-input)
  119.        (loop1))
  120.       ((eqv? #\% fc)        ; interpret next format
  121.        (set! fc (read-char format-port))
  122.        (let ((report-field? (not (eqv? #\* fc)))
  123.          (width #f))
  124.  
  125.          (define (width--) (if width (set! width (+ -1 width))))
  126.  
  127.          (define (read-u)
  128.            (string->number (read-string width char-non-numeric?)))
  129.  
  130.          (define (read-o)
  131.            (string->number
  132.         (read-string
  133.          width
  134.          (lambda (c) (not (memv c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)))))
  135.         8))
  136.  
  137.          (define (read-x)
  138.            (string->number
  139.         (read-string
  140.          width
  141.          (lambda (c) (not (memv (char-downcase c)
  142.                     '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8
  143.                           #\9 #\a #\b #\c #\d #\e #\f)))))
  144.         16))
  145.  
  146.          (define (read-radixed-unsigned)
  147.            (let ((c (peek-char input-port)))
  148.          (case c
  149.            ((#\0) (read-input-char)
  150.               (width--)
  151.               (set! c (peek-char input-port))
  152.               (case c
  153.                 ((#\x #\X) (read-input-char)
  154.                        (width--)
  155.                        (read-x))
  156.                 (else (read-o))))
  157.            (else (read-u)))))
  158.  
  159.          (define (read-ui)
  160.            (let* ((dot? #f)
  161.               (mantissa (read-word
  162.                  width
  163.                  (lambda (c) 
  164.                    (not (or (char-numeric? c)
  165.                         (cond (dot? #f)
  166.                           ((eqv? #\. c)
  167.                            (set! dot? #t)
  168.                            #t)
  169.                           (else #f)))))))
  170.               (exponent (cond
  171.                  ((not mantissa) #f)
  172.                  ((and (or (not width) (> width 1))
  173.                        (memv (peek-char input-port) '(#\E #\e)))
  174.                   (read-input-char)
  175.                   (width--)
  176.                   (let ((expsign
  177.                      (case (peek-char input-port)
  178.                        ((#\-) (read-input-char)
  179.                           (width--)
  180.                           "-")
  181.                        ((#\+) (read-input-char)
  182.                           (width--)
  183.                           "+")
  184.                        (else "")))
  185.                     (expint
  186.                      (and
  187.                       (or (not width) (positive? width))
  188.                       (read-word width char-non-numeric?))))
  189.                     (and expint (string-append
  190.                          "e" expsign expint))))
  191.                  (else #f))))
  192.          (and mantissa
  193.               (string->number
  194.                (string-append
  195.             "#i" (or mantissa "") (or exponent ""))))))
  196.  
  197.          (define (read-signed proc)
  198.            (case (peek-char input-port)
  199.          ((#\-) (read-input-char)
  200.             (width--)
  201.             (let ((ret (proc)))
  202.               (and ret (- ret))))
  203.          ((#\+) (read-input-char)
  204.             (width--)
  205.             (proc))
  206.          (else (proc))))
  207.  
  208.          ;;(trace read-word read-signed read-ui read-radixed-unsigned read-x read-o read-u)
  209.  
  210.          (cond ((not report-field?) (set! fc (read-char format-port))))
  211.          (if (char-numeric? fc) (set! width 0))
  212.          (do () ((or (eof-object? fc) (char-non-numeric? fc)))
  213.            (set! width (+ (* 10 width) (string->number (string fc))))
  214.            (set! fc (read-char format-port)))
  215.          (case fc            ;ignore h,l,L modifiers.
  216.            ((#\h #\l #\L) (set! fc (read-char format-port))))
  217.          (case fc
  218.            ((#\n) (if (not report-field?)
  219.               (slib:error 'scanf "not saving %n??"))
  220.               (add-item -1 chars-scanned)) ;-1 is special flag.
  221.            ((#\c #\C)
  222.         (if (not width) (set! width 1))
  223.         (let ((str (make-string width)))
  224.           (do ((i 0 (+ 1 i))
  225.                (c (peek-char input-port) (peek-char input-port)))
  226.               ((or (>= i width)
  227.                (eof-object? c))
  228.                (add-item report-field? (substring str 0 i)))
  229.             (string-set! str i (read-input-char)))))
  230.            ((#\s #\S)
  231.         ;;(flush-whitespace-input)
  232.         (add-item report-field? (read-word width char-whitespace?)))
  233.            ((#\[)
  234.         (set! fc (read-char format-port))
  235.         (let ((allbut #f))
  236.           (case fc
  237.             ((#\^) (set! allbut #t)
  238.                (set! fc (read-char format-port))))
  239.  
  240.           (let scanloop ((scanset (list fc)))
  241.             (set! fc (read-char format-port))
  242.             (case fc
  243.               ((#\-)
  244.                (set! fc (peek-char format-port))
  245.                (cond
  246.             ((and (char<? (car scanset) fc)
  247.                   (not (eqv? #\] fc)))
  248.              (set! fc (char->integer fc))
  249.              (do ((i (char->integer (car scanset)) (+ 1 i)))
  250.                  ((> i fc) (scanloop scanset))
  251.                (set! scanset (cons (integer->char i) scanset))))
  252.             (else (scanloop (cons #\- scanset)))))
  253.               ((#\])
  254.                (add-item report-field?
  255.                  (read-word
  256.                   width
  257.                   (if allbut (lambda (c) (memv c scanset))
  258.                       (lambda (c) (not (memv c scanset)))))))
  259.               (else (cond
  260.                  ((eof-object? fc)
  261.                   (slib:error 'scanf "unmatched [ in format"))
  262.                  (else (scanloop (cons fc scanset)))))))))
  263.            ((#\o #\O)
  264.         ;;(flush-whitespace-input)
  265.         (add-item report-field? (read-o)))
  266.            ((#\u #\U)
  267.         ;;(flush-whitespace-input)
  268.         (add-item report-field? (read-u)))
  269.            ((#\d #\D)
  270.         ;;(flush-whitespace-input)
  271.         (add-item report-field? (read-signed read-u)))
  272.            ((#\x #\X)
  273.         ;;(flush-whitespace-input)
  274.         (add-item report-field? (read-x)))
  275.            ((#\e #\E #\f #\F #\g #\G)
  276.         ;;(flush-whitespace-input)
  277.         (add-item report-field? (read-signed read-ui)))
  278.            ((#\i)
  279.         ;;(flush-whitespace-input)
  280.         (add-item report-field? (read-signed read-radixed-unsigned)))
  281.            ((#\%)
  282.         (cond ((or width (not report-field?))
  283.                (slib:error 'SCANF "%% has modifiers?"))
  284.               ((eqv? #\% (read-input-char))
  285.                (loop1))
  286.               (else (return))))
  287.            (else (slib:error 'SCANF
  288.                  "Unknown format directive:" fc)))))
  289.       ((eqv? (peek-char input-port) fc)
  290.        (read-input-char)
  291.        (loop1))
  292.       (else (return))))
  293.        ;;(trace flush-whitespace-input flush-whitespace add-item return read-string read-word loop1)
  294.        (loop1))))
  295.    (args 0)
  296.    (else '())))
  297.  
  298. ;;;This implements a Scheme-oriented version of SCANF: returns a list of
  299. ;;;objects read (rather than set!-ing values).
  300.  
  301. (define (scanf-read-list format-string . optarg)
  302.   (define input-port
  303.     (cond ((null? optarg) (current-input-port))
  304.       ((not (null? (cdr optarg)))
  305.        (slib:error 'scanf-read-list 'wrong-number-of-args optarg))
  306.       (else (car optarg))))
  307.   (cond ((input-port? input-port)
  308.      (stdio:scan-and-set format-string input-port #f))
  309.     ((string? input-port)
  310.      (call-with-input-string
  311.       input-port (lambda (input-port)
  312.                (stdio:scan-and-set format-string input-port #f))))
  313.     (else (slib:error 'scanf-read-list "argument 2 not a port"
  314.               input-port))))
  315.  
  316. (define (stdio:setter-procedure sexp)
  317.   (let ((v (gentemp)))
  318.     (cond ((symbol? sexp) `(lambda (,v) (set! ,sexp ,v) #t))
  319.       ((not (and (pair? sexp) (list? sexp)))
  320.        (slib:error 'scanf "setter expression not understood" sexp))
  321.       (else
  322.        (case (car sexp)
  323.          ((vector-ref) `(lambda (,v) (vector-set! ,@(cdr sexp) ,v) #t))
  324.          ((substring)
  325.           (require 'rev2-procedures)
  326.           `(lambda (,v) (substring-move-left!
  327.                  ,v 0 (min (string-length ,v)
  328.                        (- ,(cadddr sexp) ,(caddr sexp)))
  329.                  ,(cadr sexp) ,(caddr sexp))
  330.                #t))
  331.          ((list-ref)
  332.           (require 'rev4-optional-procedures)
  333.           `(lambda (,v) (set-car! (list-tail ,@(cdr sexp)) ,v) #t))
  334.          ((car) `(lambda (,v) (set-car! ,@(cdr sexp) ,v) #t))
  335.          ((cdr) `(lambda (,v) (set-cdr! ,@(cdr sexp) ,v) #t))
  336.          (else (slib:error 'scanf "setter not known" sexp)))))))
  337.  
  338. (defmacro scanf (format-string . args)
  339.   `(stdio:scan-and-set ,format-string (current-input-port)
  340.                ,@(map stdio:setter-procedure args)))
  341.  
  342. (defmacro sscanf (str format-string . args)
  343.   `(call-with-input-string
  344.     ,str (lambda (input-port)
  345.        (stdio:scan-and-set ,format-string input-port
  346.                    ,@(map stdio:setter-procedure args)))))
  347.  
  348. (defmacro fscanf (input-port format-string . args)
  349.   `(stdio:scan-and-set ,format-string ,input-port
  350.                ,@(map stdio:setter-procedure args)))
  351.